home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / mxcode / adnmod02 / bin2pack.pas < prev    next >
Pascal/Delphi Source File  |  1994-11-18  |  3KB  |  159 lines
  1. uses crt;
  2. var
  3. pic,pic2 : array[0..8000] of byte;
  4. f1 : file;
  5. f2 : text;
  6. count2,len : word;
  7. count : word;
  8. attr : byte;
  9.  
  10. procedure putch(b : byte);
  11. begin
  12.   pic2[count2] := b;
  13.   inc(count2);
  14. end;
  15.  
  16. function getch : byte;
  17. begin
  18.   getch := pic2[count2];
  19.   inc(count2);
  20. end;
  21.  
  22. function countb(b,attr : byte) : integer;
  23. var
  24. n : integer;
  25. begin
  26.   n := 0;
  27.   while (pic[(count+n)*2]=b) and (pic[(count+n)*2+1]=attr) do begin
  28.     inc(n);
  29.   end;
  30.   if n > 250 then n := 250;
  31.   countb := n;
  32. end;
  33.  
  34. procedure pack;
  35. var
  36. b,b2 : byte;
  37. n : integer;
  38. begin
  39.   len := 0;
  40.   attr := pic[1];
  41.   count := 0;
  42.   count2 := 0;
  43.   putch(1);
  44.   putch(attr);
  45.   while count < 4000 do begin
  46.     b := pic[count*2];
  47.     b2 := pic[count*2+1];
  48.     if b2 <> attr then begin
  49.       putch(1);
  50.       putch(b2);
  51.       attr := b2;
  52.     end;
  53.     n := 0;
  54.     n := countb(b,attr);
  55.     if n > 1 then begin
  56.       if b = 32 then begin
  57.         putch(3);
  58.         putch(n);
  59.         inc(count,n-1)
  60.       end
  61.       else begin
  62.         putch(2);
  63.         putch(n);
  64.         putch(b);
  65.         inc(count,n-1);
  66.       end;
  67.     end
  68.     else if b < 8 then begin
  69.       putch(7);
  70.       putch(b);
  71.     end
  72.     else putch(b);
  73.     inc(count);
  74.   end;
  75.   putch(0);
  76.   len := count2;
  77. end;
  78.  
  79. procedure putpic(b : byte);
  80. begin
  81.   pic[count*2] := b;
  82.   pic[count*2+1] := attr;
  83.   memw[$b800:count*2] := attr*256+b;
  84.   inc(count);
  85. end;
  86.  
  87. procedure unpack;
  88. var
  89. b,b2 : byte;
  90. n : integer;
  91. begin
  92.   attr := 7;
  93.   count := 0;
  94.   count2 := 0;
  95.   while b <> 0 do begin
  96.     b := getch;
  97.     if b = 1 then begin
  98.       attr := getch;
  99.     end
  100.     else if b = 2 then begin
  101.       b2 := getch;
  102.       b := getch;
  103.       for n := 1 to b2 do putpic(b);
  104.     end
  105.     else if b = 3 then begin
  106.       b2 := getch;
  107.       for n := 1 to b2 do putpic(32);
  108.     end
  109.     else if b = 7 then begin
  110.       b := getch;
  111.       putch(b);
  112.     end
  113.     else putpic(b);
  114.   end;
  115. end;
  116.  
  117. procedure save;
  118. var
  119. n : integer;
  120. x : integer;
  121. begin
  122.   x := 1;
  123.   writeln(f2,'const');
  124.   writeln(f2,'imagedata_len = ',len,';');
  125.   writeln(f2,'imagedata : array[0..',len-1,'] of byte = (');
  126.   for n := 1 to len-1 do begin
  127.     write(f2,pic2[n-1],',');
  128.     inc(x);
  129.     if x > 12 then begin
  130.       x := 1;
  131.       writeln(f2);
  132.     end;
  133.   end;
  134.   writeln(f2,pic2[len-1],');');
  135. end;
  136.  
  137. begin
  138.   textmode(co80 +font8x8);
  139.   assign(f1,'adnpic.bin');
  140.   assign(f2,'adnpic.inc');
  141.   reset(f1,1);
  142.   rewrite(f2);
  143.   blockread(f1,pic,8000);
  144.   fillchar(pic2,8000,0);
  145.   move(pic,mem[$b800:0],8000);
  146.   readkey;
  147.   pack;
  148.   clrscr;
  149.   fillchar(pic,8000,0);
  150.   unpack;
  151.   {move(pic[0],mem[$b800:0],8000);}
  152.   readkey;
  153.   save;
  154.   close(f1);
  155.   close(f2);
  156.   textmode(co80);
  157.   writeln(len);
  158. end.
  159.